home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload Trio 2 / Shareware Overload Trio Volume 2 (Chestnut CD-ROM).ISO / dir43 / perldoss.zip / DOLIST.C < prev    next >
C/C++ Source or Header  |  1991-11-28  |  47KB  |  1,991 lines
  1. /* $RCSfile: dolist.c,v $$Revision: 4.0.1.4 $$Date: 91/11/11 16:33:19 $
  2.  *
  3.  *    Copyright (c) 1991, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  * $Log:    dolist.c,v $
  9.  * Revision 4.0.1.4  91/11/11  16:33:19  lwall
  10.  * patch19: added little-endian pack/unpack options
  11.  * patch19: sort $subname was busted by changes in 4.018
  12.  *
  13.  * Revision 4.0.1.3  91/11/05  17:07:02  lwall
  14.  * patch11: prepared for ctype implementations that don't define isascii()
  15.  * patch11: /$foo/o optimizer could access deallocated data
  16.  * patch11: certain optimizations of //g in array context returned too many values
  17.  * patch11: regexp with no parens in array context returned wacky $`, $& and $'
  18.  * patch11: $' not set right on some //g
  19.  * patch11: added some support for 64-bit integers
  20.  * patch11: grep of a split lost its values
  21.  * patch11: added sort {} LIST
  22.  * patch11: multiple reallocations now avoided in 1 .. 100000
  23.  *
  24.  * Revision 4.0.1.2  91/06/10  01:22:15  lwall
  25.  * patch10: //g only worked first time through
  26.  *
  27.  * Revision 4.0.1.1  91/06/07  10:58:28  lwall
  28.  * patch4: new copyright notice
  29.  * patch4: added global modifier for pattern matches
  30.  * patch4: // wouldn't use previous pattern if it started with a null character
  31.  * patch4: //o and s///o now optimize themselves fully at runtime
  32.  * patch4: $` was busted inside s///
  33.  * patch4: caller($arg) didn't work except under debugger
  34.  *
  35.  * Revision 4.0  91/03/20  01:08:03  lwall
  36.  * 4.0 baseline.
  37.  *
  38.  */
  39.  
  40.  
  41. #include "EXTERN.h"
  42. #include "perl.h"
  43.  
  44.  
  45.  
  46.  
  47. #ifdef BUGGY_MSC
  48.  #pragma function(memcmp)
  49. #endif /* BUGGY_MSC */
  50.  
  51.  
  52. int
  53. do_match(str,arg,gimme,arglast)
  54. STR *str;
  55. register ARG *arg;
  56. int gimme;
  57. int *arglast;
  58. {
  59.     register STR **st = stack->ary_array;
  60.     register SPAT *spat = arg[2].arg_ptr.arg_spat;
  61.     register char *t;
  62.     register int sp = arglast[0] + 1;
  63.     STR *srchstr = st[sp];
  64.     register char *s = str_get(st[sp]);
  65.     char *strend = s + st[sp]->str_cur;
  66.     STR *tmpstr;
  67.     char *myhint = hint;
  68.     int global;
  69.     int safebase;
  70.  
  71.  
  72.     hint = Nullch;
  73.     if (!spat) {
  74.     if (gimme == G_ARRAY)
  75.         return --sp;
  76.     str_set(str,Yes);
  77.     STABSET(str);
  78.     st[sp] = str;
  79.     return sp;
  80.     }
  81.     global = spat->spat_flags & SPAT_GLOBAL;
  82.     safebase = (gimme == G_ARRAY) || global;
  83.     if (!s)
  84.     fatal("panic: do_match");
  85.     if (spat->spat_flags & SPAT_USED) {
  86. #ifdef DEBUGGING
  87.     if (debug & 8)
  88.         deb("2.SPAT USED\n");
  89. #endif
  90.     if (gimme == G_ARRAY)
  91.         return --sp;
  92.     str_set(str,No);
  93.     STABSET(str);
  94.     st[sp] = str;
  95.     return sp;
  96.     }
  97.     --sp;
  98.     if (spat->spat_runtime) {
  99.     nointrp = "|)";
  100.     sp = eval(spat->spat_runtime,G_SCALAR,sp);
  101.     st = stack->ary_array;
  102.     t = str_get(tmpstr = st[sp--]);
  103.     nointrp = "";
  104. #ifdef DEBUGGING
  105.     if (debug & 8)
  106.         deb("2.SPAT /%s/\n",t);
  107. #endif
  108.     if (spat->spat_regexp) {
  109.         regfree(spat->spat_regexp);
  110.         spat->spat_regexp = Null(REGEXP*);    /* crucial if regcomp aborts */
  111.     }
  112.     spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
  113.         spat->spat_flags & SPAT_FOLD);
  114.     if (!spat->spat_regexp->prelen && lastspat)
  115.         spat = lastspat;
  116.     if (spat->spat_flags & SPAT_KEEP) {
  117.         scanconst(spat,spat->spat_regexp->precomp, spat->spat_regexp->prelen);
  118.         if (spat->spat_runtime)
  119.         arg_free(spat->spat_runtime);    /* it won't change, so */
  120.         spat->spat_runtime = Nullarg;    /* no point compiling again */
  121.         hoistmust(spat);
  122.         if (curcmd->c_expr && (curcmd->c_flags & CF_OPTIMIZE) == CFT_EVAL) {
  123.         curcmd->c_flags &= ~CF_OPTIMIZE;
  124.         opt_arg(curcmd, 1, curcmd->c_type == C_EXPR);
  125.         }
  126.     }
  127.     if (global) {
  128.         if (spat->spat_regexp->startp[0]) {
  129.         s = spat->spat_regexp->endp[0];
  130.         }
  131.     }
  132.     else if (!spat->spat_regexp->nparens)
  133.         gimme = G_SCALAR;            /* accidental array context? */
  134.     if (regexec(spat->spat_regexp, s, strend, s, 0,
  135.       srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
  136.       safebase)) {
  137.         if (spat->spat_regexp->subbase || global)
  138.         curspat = spat;
  139.         lastspat = spat;
  140.         goto gotcha;
  141.     }
  142.     else {
  143.         if (gimme == G_ARRAY)
  144.         return sp;
  145.         str_sset(str,&str_no);
  146.         STABSET(str);
  147.         st[++sp] = str;
  148.         return sp;
  149.     }
  150.     }
  151.     else {
  152. #ifdef DEBUGGING
  153.     if (debug & 8) {
  154.         char ch;
  155.  
  156.  
  157.         if (spat->spat_flags & SPAT_ONCE)
  158.         ch = '?';
  159.         else
  160.         ch = '/';
  161.         deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
  162.     }
  163. #endif
  164.     if (!spat->spat_regexp->prelen && lastspat)
  165.         spat = lastspat;
  166.     t = s;
  167.     play_it_again:
  168.     if (global && spat->spat_regexp->startp[0])
  169.         t = s = spat->spat_regexp->endp[0];
  170.     if (myhint) {
  171.         if (myhint < s || myhint > strend)
  172.         fatal("panic: hint in do_match");
  173.         s = myhint;
  174.         if (spat->spat_regexp->regback >= 0) {
  175.         s -= spat->spat_regexp->regback;
  176.         if (s < t)
  177.             s = t;
  178.         }
  179.         else
  180.         s = t;
  181.     }
  182.     else if (spat->spat_short) {
  183.         if (spat->spat_flags & SPAT_SCANFIRST) {
  184.         if (srchstr->str_pok & SP_STUDIED) {
  185.             if (screamfirst[spat->spat_short->str_rare] < 0)
  186.             goto nope;
  187.             else if (!(s = screaminstr(srchstr,spat->spat_short)))
  188.             goto nope;
  189.             else if (spat->spat_flags & SPAT_ALL)
  190.             goto yup;
  191.         }
  192. #ifndef lint
  193.         else if (!(s = fbminstr((unsigned char*)s,
  194.           (unsigned char*)strend, spat->spat_short)))
  195.             goto nope;
  196. #endif
  197.         else if (spat->spat_flags & SPAT_ALL)
  198.             goto yup;
  199.         if (s && spat->spat_regexp->regback >= 0) {
  200.             ++spat->spat_short->str_u.str_useful;
  201.             s -= spat->spat_regexp->regback;
  202.             if (s < t)
  203.             s = t;
  204.         }
  205.         else
  206.             s = t;
  207.         }
  208.         else if (!multiline && (*spat->spat_short->str_ptr != *s ||
  209.           bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
  210.         goto nope;
  211.         if (--spat->spat_short->str_u.str_useful < 0) {
  212.         str_free(spat->spat_short);
  213.         spat->spat_short = Nullstr;    /* opt is being useless */
  214.         }
  215.     }
  216.     if (!spat->spat_regexp->nparens && !global) {
  217.         gimme = G_SCALAR;            /* accidental array context? */
  218.         safebase = FALSE;
  219.     }
  220.     if (regexec(spat->spat_regexp, s, strend, t, 0,
  221.       srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
  222.       safebase)) {
  223.         if (spat->spat_regexp->subbase || global)
  224.         curspat = spat;
  225.         lastspat = spat;
  226.         if (spat->spat_flags & SPAT_ONCE)
  227.         spat->spat_flags |= SPAT_USED;
  228.         goto gotcha;
  229.     }
  230.     else {
  231.         if (global)
  232.         spat->spat_regexp->startp[0] = Nullch;
  233.         if (gimme == G_ARRAY)
  234.         return sp;
  235.         str_sset(str,&str_no);
  236.         STABSET(str);
  237.         st[++sp] = str;
  238.         return sp;
  239.     }
  240.     }
  241.     /*NOTREACHED*/
  242.  
  243.  
  244.   gotcha:
  245.     if (gimme == G_ARRAY) {
  246.     int iters, i, len;
  247.  
  248.  
  249.     iters = spat->spat_regexp->nparens;
  250.     if (global && !iters)
  251.         i = 1;
  252.     else
  253.         i = 0;
  254.     if (sp + iters + i >= stack->ary_max) {
  255.         astore(stack,sp + iters + i, Nullstr);
  256.         st = stack->ary_array;        /* possibly realloced */
  257.     }
  258.  
  259.  
  260.     for (i = !i; i <= iters; i++) {
  261.         st[++sp] = str_mortal(&str_no);
  262.         /*SUPPRESS 560*/
  263.         if (s = spat->spat_regexp->startp[i]) {
  264.         len = spat->spat_regexp->endp[i] - s;
  265.         if (len > 0)
  266.             str_nset(st[sp],s,len);
  267.         }
  268.     }
  269.     if (global)
  270.         goto play_it_again;
  271.     return sp;
  272.     }
  273.     else {
  274.     str_sset(str,&str_yes);
  275.     STABSET(str);
  276.     st[++sp] = str;
  277.     return sp;
  278.     }
  279.  
  280.  
  281. yup:
  282.     ++spat->spat_short->str_u.str_useful;
  283.     lastspat = spat;
  284.     if (spat->spat_flags & SPAT_ONCE)
  285.     spat->spat_flags |= SPAT_USED;
  286.     if (global) {
  287.     spat->spat_regexp->subbeg = t;
  288.     spat->spat_regexp->subend = strend;
  289.     spat->spat_regexp->startp[0] = s;
  290.     spat->spat_regexp->endp[0] = s + spat->spat_short->str_cur;
  291.     curspat = spat;
  292.     goto gotcha;
  293.     }
  294.     if (sawampersand) {
  295.     char *tmps;
  296.  
  297.  
  298.     if (spat->spat_regexp->subbase)
  299.         Safefree(spat->spat_regexp->subbase);
  300.     tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
  301.     spat->spat_regexp->subbeg = tmps;
  302.     spat->spat_regexp->subend = tmps + (strend-t);
  303.     tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
  304.     spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
  305.     curspat = spat;
  306.     }
  307.     str_sset(str,&str_yes);
  308.     STABSET(str);
  309.     st[++sp] = str;
  310.     return sp;
  311.  
  312.  
  313. nope:
  314.     spat->spat_regexp->startp[0] = Nullch;
  315.     ++spat->spat_short->str_u.str_useful;
  316.     if (global)
  317.     spat->spat_regexp->startp[0] = Nullch;
  318.     if (gimme == G_ARRAY)
  319.     return sp;
  320.     str_sset(str,&str_no);
  321.     STABSET(str);
  322.     st[++sp] = str;
  323.     return sp;
  324. }
  325.  
  326.  
  327. #ifdef BUGGY_MSC
  328.  #pragma intrinsic(memcmp)
  329. #endif /* BUGGY_MSC */
  330.  
  331.  
  332. int
  333. do_split(str,spat,limit,gimme,arglast)
  334. STR *str;
  335. register SPAT *spat;
  336. register int limit;
  337. int gimme;
  338. int *arglast;
  339. {
  340.     register ARRAY *ary = stack;
  341.     STR **st = ary->ary_array;
  342.     register int sp = arglast[0] + 1;
  343.     register char *s = str_get(st[sp]);
  344.     char *strend = s + st[sp--]->str_cur;
  345.     register STR *dstr;
  346.     register char *m;
  347.     int iters = 0;
  348.     int maxiters = (strend - s) + 10;
  349.     int i;
  350.     char *orig;
  351.     int origlimit = limit;
  352.     int realarray = 0;
  353.  
  354.  
  355.     if (!spat || !s)
  356.     fatal("panic: do_split");
  357.     else if (spat->spat_runtime) {
  358.     nointrp = "|)";
  359.     sp = eval(spat->spat_runtime,G_SCALAR,sp);
  360.     st = stack->ary_array;
  361.     m = str_get(dstr = st[sp--]);
  362.     nointrp = "";
  363.     if (*m == ' ' && dstr->str_cur == 1) {
  364.         str_set(dstr,"\\s+");
  365.         m = dstr->str_ptr;
  366.         spat->spat_flags |= SPAT_SKIPWHITE;
  367.     }
  368.     if (spat->spat_regexp) {
  369.         regfree(spat->spat_regexp);
  370.         spat->spat_regexp = Null(REGEXP*);    /* avoid possible double free */
  371.     }
  372.     spat->spat_regexp = regcomp(m,m+dstr->str_cur,
  373.         spat->spat_flags & SPAT_FOLD);
  374.     if (spat->spat_flags & SPAT_KEEP ||
  375.         (spat->spat_runtime->arg_type == O_ITEM &&
  376.           (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
  377.         arg_free(spat->spat_runtime);    /* it won't change, so */
  378.         spat->spat_runtime = Nullarg;    /* no point compiling again */
  379.     }
  380.     }
  381. #ifdef DEBUGGING
  382.     if (debug & 8) {
  383.     deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
  384.     }
  385. #endif
  386.     ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
  387.     if (ary && (gimme != G_ARRAY || (spat->spat_flags & SPAT_ONCE))) {
  388.     realarray = 1;
  389.     if (!(ary->ary_flags & ARF_REAL)) {
  390.         ary->ary_flags |= ARF_REAL;
  391.         for (i = ary->ary_fill; i >= 0; i--)
  392.         ary->ary_array[i] = Nullstr;    /* don't free mere refs */
  393.     }
  394.     ary->ary_fill = -1;
  395.     sp = -1;    /* temporarily switch stacks */
  396.     }
  397.     else
  398.     ary = stack;
  399.     orig = s;
  400.     if (spat->spat_flags & SPAT_SKIPWHITE) {
  401.     while (isSPACE(*s))
  402.         s++;
  403.     }
  404.     if (!limit)
  405.     limit = maxiters + 2;
  406.     if (strEQ("\\s+",spat->spat_regexp->precomp)) {
  407.     while (--limit) {
  408.         /*SUPPRESS 530*/
  409.         for (m = s; m < strend && !isSPACE(*m); m++) ;
  410.         if (m >= strend)
  411.         break;
  412.         dstr = Str_new(30,m-s);
  413.         str_nset(dstr,s,m-s);
  414.         if (!realarray)
  415.         str_2mortal(dstr);
  416.         (void)astore(ary, ++sp, dstr);
  417.         /*SUPPRESS 530*/
  418.         for (s = m + 1; s < strend && isSPACE(*s); s++) ;
  419.     }
  420.     }
  421.     else if (strEQ("^",spat->spat_regexp->precomp)) {
  422.     while (--limit) {
  423.         /*SUPPRESS 530*/
  424.         for (m = s; m < strend && *m != '\n'; m++) ;
  425.         m++;
  426.         if (m >= strend)
  427.         break;
  428.         dstr = Str_new(30,m-s);
  429.         str_nset(dstr,s,m-s);
  430.         if (!realarray)
  431.         str_2mortal(dstr);
  432.         (void)astore(ary, ++sp, dstr);
  433.         s = m;
  434.     }
  435.     }
  436.     else if (spat->spat_short) {
  437.     i = spat->spat_short->str_cur;
  438.     if (i == 1) {
  439.         int fold = (spat->spat_flags & SPAT_FOLD);
  440.  
  441.  
  442.         i = *spat->spat_short->str_ptr;
  443.         if (fold && isUPPER(i))
  444.         i = tolower(i);
  445.         while (--limit) {
  446.         if (fold) {
  447.             for ( m = s;
  448.               m < strend && *m != i &&
  449.                 (!isUPPER(*m) || tolower(*m) != i);
  450.               m++)            /*SUPPRESS 530*/
  451.             ;
  452.         }
  453.         else                /*SUPPRESS 530*/
  454.             for (m = s; m < strend && *m != i; m++) ;
  455.         if (m >= strend)
  456.             break;
  457.         dstr = Str_new(30,m-s);
  458.         str_nset(dstr,s,m-s);
  459.         if (!realarray)
  460.             str_2mortal(dstr);
  461.         (void)astore(ary, ++sp, dstr);
  462.         s = m + 1;
  463.         }
  464.     }
  465.     else {
  466. #ifndef lint
  467.         while (s < strend && --limit &&
  468.           (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
  469.             spat->spat_short)) )
  470. #endif
  471.         {
  472.         dstr = Str_new(31,m-s);
  473.         str_nset(dstr,s,m-s);
  474.         if (!realarray)
  475.             str_2mortal(dstr);
  476.         (void)astore(ary, ++sp, dstr);
  477.         s = m + i;
  478.         }
  479.     }
  480.     }
  481.     else {
  482.     maxiters += (strend - s) * spat->spat_regexp->nparens;
  483.     while (s < strend && --limit &&
  484.         regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
  485.         if (spat->spat_regexp->subbase
  486.           && spat->spat_regexp->subbase != orig) {
  487.         m = s;
  488.         s = orig;
  489.         orig = spat->spat_regexp->subbase;
  490.         s = orig + (m - s);
  491.         strend = s + (strend - m);
  492.         }
  493.         m = spat->spat_regexp->startp[0];
  494.         dstr = Str_new(32,m-s);
  495.         str_nset(dstr,s,m-s);
  496.         if (!realarray)
  497.         str_2mortal(dstr);
  498.         (void)astore(ary, ++sp, dstr);
  499.         if (spat->spat_regexp->nparens) {
  500.         for (i = 1; i <= spat->spat_regexp->nparens; i++) {
  501.             s = spat->spat_regexp->startp[i];
  502.             m = spat->spat_regexp->endp[i];
  503.             dstr = Str_new(33,m-s);
  504.             str_nset(dstr,s,m-s);
  505.             if (!realarray)
  506.             str_2mortal(dstr);
  507.             (void)astore(ary, ++sp, dstr);
  508.         }
  509.         }
  510.         s = spat->spat_regexp->endp[0];
  511.     }
  512.     }
  513.     if (realarray)
  514.     iters = sp + 1;
  515.     else
  516.     iters = sp - arglast[0];
  517.     if (iters > maxiters)
  518.     fatal("Split loop");
  519.     if (s < strend || origlimit) {    /* keep field after final delim? */
  520.     dstr = Str_new(34,strend-s);
  521.     str_nset(dstr,s,strend-s);
  522.     if (!realarray)
  523.         str_2mortal(dstr);
  524.     (void)astore(ary, ++sp, dstr);
  525.     iters++;
  526.     }
  527.     else {
  528. #ifndef I286x
  529.     while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
  530.         iters--,sp--;
  531. #else
  532.     char *zaps;
  533.     int   zapb;
  534.  
  535.  
  536.     if (iters > 0) {
  537.         zaps = str_get(afetch(ary,sp,FALSE));
  538.         zapb = (int) *zaps;
  539.     }
  540.     
  541.     while (iters > 0 && (!zapb)) {
  542.         iters--,sp--;
  543.         if (iters > 0) {
  544.         zaps = str_get(afetch(ary,iters-1,FALSE));
  545.         zapb = (int) *zaps;
  546.         }
  547.     }
  548. #endif
  549.     }
  550.     if (realarray) {
  551.     ary->ary_fill = sp;
  552.     if (gimme == G_ARRAY) {
  553.         sp++;
  554.         astore(stack, arglast[0] + 1 + sp, Nullstr);
  555.         Copy(ary->ary_array, stack->ary_array + arglast[0] + 1, sp, STR*);
  556.         return arglast[0] + sp;
  557.     }
  558.     }
  559.     else {
  560.     if (gimme == G_ARRAY)
  561.         return sp;
  562.     }
  563.     sp = arglast[0] + 1;
  564.     str_numset(str,(double)iters);
  565.     STABSET(str);
  566.     st[sp] = str;
  567.     return sp;
  568. }
  569.  
  570.  
  571. int
  572. do_unpack(str,gimme,arglast)
  573. STR *str;
  574. int gimme;
  575. int *arglast;
  576. {
  577.     STR **st = stack->ary_array;
  578.     register int sp = arglast[0] + 1;
  579.     register char *pat = str_get(st[sp++]);
  580.     register char *s = str_get(st[sp]);
  581.     char *strend = s + st[sp--]->str_cur;
  582.     char *strbeg = s;
  583.     register char *patend = pat + st[sp]->str_cur;
  584.     int datumtype;
  585.     register int len;
  586.     register int bits;
  587.  
  588.  
  589.     /* These must not be in registers: */
  590.     short ashort;
  591.     int aint;
  592.     long along;
  593. #ifdef QUAD
  594.     quad aquad;
  595. #endif
  596.     unsigned short aushort;
  597.     unsigned int auint;
  598.     unsigned long aulong;
  599. #ifdef QUAD
  600.     unsigned quad auquad;
  601. #endif
  602.     char *aptr;
  603.     float afloat;
  604.     double adouble;
  605.     int checksum = 0;
  606.     unsigned long culong;
  607.     double cdouble;
  608.  
  609.  
  610.     if (gimme != G_ARRAY) {        /* arrange to do first one only */
  611.     /*SUPPRESS 530*/
  612.     for (patend = pat; !isALPHA(*patend) || *patend == 'x'; patend++) ;
  613.     if (index("aAbBhH", *patend) || *pat == '%') {
  614.         patend++;
  615.         while (isDIGIT(*patend) || *patend == '*')
  616.         patend++;
  617.     }
  618.     else
  619.         patend++;
  620.     }
  621.     sp--;
  622.     while (pat < patend) {
  623.       reparse:
  624.     datumtype = *pat++;
  625.     if (pat >= patend)
  626.         len = 1;
  627.     else if (*pat == '*') {
  628.         len = strend - strbeg;    /* long enough */
  629.         pat++;
  630.     }
  631.     else if (isDIGIT(*pat)) {
  632.         len = *pat++ - '0';
  633.         while (isDIGIT(*pat))
  634.         len = (len * 10) + (*pat++ - '0');
  635.     }
  636.     else
  637.         len = (datumtype != '@');
  638.     switch(datumtype) {
  639.     default:
  640.         break;
  641.     case '%':
  642.         if (len == 1 && pat[-1] != '1')
  643.         len = 16;
  644.         checksum = len;
  645.         culong = 0;
  646.         cdouble = 0;
  647.         if (pat < patend)
  648.         goto reparse;
  649.         break;
  650.     case '@':
  651.         if (len > strend - s)
  652.         fatal("@ outside of string");
  653.         s = strbeg + len;
  654.         break;
  655.     case 'X':
  656.         if (len > s - strbeg)
  657.         fatal("X outside of string");
  658.         s -= len;
  659.         break;
  660.     case 'x':
  661.         if (len > strend - s)
  662.         fatal("x outside of string");
  663.         s += len;
  664.         break;
  665.     case 'A':
  666.     case 'a':
  667.         if (len > strend - s)
  668.         len = strend - s;
  669.         if (checksum)
  670.         goto uchar_checksum;
  671.         str = Str_new(35,len);
  672.         str_nset(str,s,len);
  673.         s += len;
  674.         if (datumtype == 'A') {
  675.         aptr = s;    /* borrow register */
  676.         s = str->str_ptr + len - 1;
  677.         while (s >= str->str_ptr && (!*s || isSPACE(*s)))
  678.             s--;
  679.         *++s = '\0';
  680.         str->str_cur = s - str->str_ptr;
  681.         s = aptr;    /* unborrow register */
  682.         }
  683.         (void)astore(stack, ++sp, str_2mortal(str));
  684.         break;
  685.     case 'B':
  686.     case 'b':
  687.         if (pat[-1] == '*' || len > (strend - s) * 8)
  688.         len = (strend - s) * 8;
  689.         str = Str_new(35, len + 1);
  690.         str->str_cur = len;
  691.         str->str_pok = 1;
  692.         aptr = pat;            /* borrow register */
  693.         pat = str->str_ptr;
  694.         if (datumtype == 'b') {
  695.         aint = len;
  696.         for (len = 0; len < aint; len++) {
  697.             if (len & 7)        /*SUPPRESS 595*/
  698.             bits >>= 1;
  699.             else
  700.             bits = *s++;
  701.             *pat++ = '0' + (bits & 1);
  702.         }
  703.         }
  704.         else {
  705.         aint = len;
  706.         for (len = 0; len < aint; len++) {
  707.             if (len & 7)
  708.             bits <<= 1;
  709.             else
  710.             bits = *s++;
  711.             *pat++ = '0' + ((bits & 128) != 0);
  712.         }
  713.         }
  714.         *pat = '\0';
  715.         pat = aptr;            /* unborrow register */
  716.         (void)astore(stack, ++sp, str_2mortal(str));
  717.         break;
  718.     case 'H':
  719.     case 'h':
  720.         if (pat[-1] == '*' || len > (strend - s) * 2)
  721.         len = (strend - s) * 2;
  722.         str = Str_new(35, len + 1);
  723.         str->str_cur = len;
  724.         str->str_pok = 1;
  725.         aptr = pat;            /* borrow register */
  726.         pat = str->str_ptr;
  727.         if (datumtype == 'h') {
  728.         aint = len;
  729.         for (len = 0; len < aint; len++) {
  730.             if (len & 1)
  731.             bits >>= 4;
  732.             else
  733.             bits = *s++;
  734.             *pat++ = hexdigit[bits & 15];
  735.         }
  736.         }
  737.         else {
  738.         aint = len;
  739.         for (len = 0; len < aint; len++) {
  740.             if (len & 1)
  741.             bits <<= 4;
  742.             else
  743.             bits = *s++;
  744.             *pat++ = hexdigit[(bits >> 4) & 15];
  745.         }
  746.         }
  747.         *pat = '\0';
  748.         pat = aptr;            /* unborrow register */
  749.         (void)astore(stack, ++sp, str_2mortal(str));
  750.         break;
  751.     case 'c':
  752.         if (len > strend - s)
  753.         len = strend - s;
  754.         if (checksum) {
  755.         while (len-- > 0) {
  756.             aint = *s++;
  757.             if (aint >= 128)    /* fake up signed chars */
  758.             aint -= 256;
  759.             culong += aint;
  760.         }
  761.         }
  762.         else {
  763.         while (len-- > 0) {
  764.             aint = *s++;
  765.             if (aint >= 128)    /* fake up signed chars */
  766.             aint -= 256;
  767.             str = Str_new(36,0);
  768.             str_numset(str,(double)aint);
  769.             (void)astore(stack, ++sp, str_2mortal(str));
  770.         }
  771.         }
  772.         break;
  773.     case 'C':
  774.         if (len > strend - s)
  775.         len = strend - s;
  776.         if (checksum) {
  777.           uchar_checksum:
  778.         while (len-- > 0) {
  779.             auint = *s++ & 255;
  780.             culong += auint;
  781.         }
  782.         }
  783.         else {
  784.         while (len-- > 0) {
  785.             auint = *s++ & 255;
  786.             str = Str_new(37,0);
  787.             str_numset(str,(double)auint);
  788.             (void)astore(stack, ++sp, str_2mortal(str));
  789.         }
  790.         }
  791.         break;
  792.     case 's':
  793.         along = (strend - s) / sizeof(short);
  794.         if (len > along)
  795.         len = along;
  796.         if (checksum) {
  797.         while (len-- > 0) {
  798.             bcopy(s,(char*)&ashort,sizeof(short));
  799.             s += sizeof(short);
  800.             culong += ashort;
  801.         }
  802.         }
  803.         else {
  804.         while (len-- > 0) {
  805.             bcopy(s,(char*)&ashort,sizeof(short));
  806.             s += sizeof(short);
  807.             str = Str_new(38,0);
  808.             str_numset(str,(double)ashort);
  809.             (void)astore(stack, ++sp, str_2mortal(str));
  810.         }
  811.         }
  812.         break;
  813.     case 'v':
  814.     case 'n':
  815.     case 'S':
  816.         along = (strend - s) / sizeof(unsigned short);
  817.         if (len > along)
  818.         len = along;
  819.         if (checksum) {
  820.         while (len-- > 0) {
  821.             bcopy(s,(char*)&aushort,sizeof(unsigned short));
  822.             s += sizeof(unsigned short);
  823. #ifdef HAS_NTOHS
  824.             if (datumtype == 'n')
  825.             aushort = ntohs(aushort);
  826. #endif
  827. #ifdef HAS_VTOHS
  828.             if (datumtype == 'v')
  829.             aushort = vtohs(aushort);
  830. #endif
  831.             culong += aushort;
  832.         }
  833.         }
  834.         else {
  835.         while (len-- > 0) {
  836.             bcopy(s,(char*)&aushort,sizeof(unsigned short));
  837.             s += sizeof(unsigned short);
  838.             str = Str_new(39,0);
  839. #ifdef HAS_NTOHS
  840.             if (datumtype == 'n')
  841.             aushort = ntohs(aushort);
  842. #endif
  843. #ifdef HAS_VTOHS
  844.             if (datumtype == 'v')
  845.             aushort = vtohs(aushort);
  846. #endif
  847.             str_numset(str,(double)aushort);
  848.             (void)astore(stack, ++sp, str_2mortal(str));
  849.         }
  850.         }
  851.         break;
  852.     case 'i':
  853.         along = (strend - s) / sizeof(int);
  854.         if (len > along)
  855.         len = along;
  856.         if (checksum) {
  857.         while (len-- > 0) {
  858.             bcopy(s,(char*)&aint,sizeof(int));
  859.             s += sizeof(int);
  860.             if (checksum > 32)
  861.             cdouble += (double)aint;
  862.             else
  863.             culong += aint;
  864.         }
  865.         }
  866.         else {
  867.         while (len-- > 0) {
  868.             bcopy(s,(char*)&aint,sizeof(int));
  869.             s += sizeof(int);
  870.             str = Str_new(40,0);
  871.             str_numset(str,(double)aint);
  872.             (void)astore(stack, ++sp, str_2mortal(str));
  873.         }
  874.         }
  875.         break;
  876.     case 'I':
  877.         along = (strend - s) / sizeof(unsigned int);
  878.         if (len > along)
  879.         len = along;
  880.         if (checksum) {
  881.         while (len-- > 0) {
  882.             bcopy(s,(char*)&auint,sizeof(unsigned int));
  883.             s += sizeof(unsigned int);
  884.             if (checksum > 32)
  885.             cdouble += (double)auint;
  886.             else
  887.             culong += auint;
  888.         }
  889.         }
  890.         else {
  891.         while (len-- > 0) {
  892.             bcopy(s,(char*)&auint,sizeof(unsigned int));
  893.             s += sizeof(unsigned int);
  894.             str = Str_new(41,0);
  895.             str_numset(str,(double)auint);
  896.             (void)astore(stack, ++sp, str_2mortal(str));
  897.         }
  898.         }
  899.         break;
  900.     case 'l':
  901.         along = (strend - s) / sizeof(long);
  902.         if (len > along)
  903.         len = along;
  904.         if (checksum) {
  905.         while (len-- > 0) {
  906.             bcopy(s,(char*)&along,sizeof(long));
  907.             s += sizeof(long);
  908.             if (checksum > 32)
  909.             cdouble += (double)along;
  910.             else
  911.             culong += along;
  912.         }
  913.         }
  914.         else {
  915.         while (len-- > 0) {
  916.             bcopy(s,(char*)&along,sizeof(long));
  917.             s += sizeof(long);
  918.             str = Str_new(42,0);
  919.             str_numset(str,(double)along);
  920.             (void)astore(stack, ++sp, str_2mortal(str));
  921.         }
  922.         }
  923.         break;
  924.     case 'V':
  925.     case 'N':
  926.     case 'L':
  927.         along = (strend - s) / sizeof(unsigned long);
  928.         if (len > along)
  929.         len = along;
  930.         if (checksum) {
  931.         while (len-- > 0) {
  932.             bcopy(s,(char*)&aulong,sizeof(unsigned long));
  933.             s += sizeof(unsigned long);
  934. #ifdef HAS_NTOHL
  935.             if (datumtype == 'N')
  936.             aulong = ntohl(aulong);
  937. #endif
  938. #ifdef HAS_VTOHL
  939.             if (datumtype == 'V')
  940.             aulong = vtohl(aulong);
  941. #endif
  942.             if (checksum > 32)
  943.             cdouble += (double)aulong;
  944.             else
  945.             culong += aulong;
  946.         }
  947.         }
  948.         else {
  949.         while (len-- > 0) {
  950.             bcopy(s,(char*)&aulong,sizeof(unsigned long));
  951.             s += sizeof(unsigned long);
  952.             str = Str_new(43,0);
  953. #ifdef HAS_NTOHL
  954.             if (datumtype == 'N')
  955.             aulong = ntohl(aulong);
  956. #endif
  957. #ifdef HAS_VTOHL
  958.             if (datumtype == 'V')
  959.             aulong = vtohl(aulong);
  960. #endif
  961.             str_numset(str,(double)aulong);
  962.             (void)astore(stack, ++sp, str_2mortal(str));
  963.         }
  964.         }
  965.         break;
  966.     case 'p':
  967.         along = (strend - s) / sizeof(char*);
  968.         if (len > along)
  969.         len = along;
  970.         while (len-- > 0) {
  971.         if (sizeof(char*) > strend - s)
  972.             break;
  973.         else {
  974.             bcopy(s,(char*)&aptr,sizeof(char*));
  975.             s += sizeof(char*);
  976.         }
  977.         str = Str_new(44,0);
  978.         if (aptr)
  979.             str_set(str,aptr);
  980.         (void)astore(stack, ++sp, str_2mortal(str));
  981.         }
  982.         break;
  983. #ifdef QUAD
  984.     case 'q':
  985.         while (len-- > 0) {
  986.         if (s + sizeof(quad) > strend)
  987.             aquad = 0;
  988.         else {
  989.             bcopy(s,(char*)&aquad,sizeof(quad));
  990.             s += sizeof(quad);
  991.         }
  992.         str = Str_new(42,0);
  993.         str_numset(str,(double)aquad);
  994.         (void)astore(stack, ++sp, str_2mortal(str));
  995.         }
  996.         break;
  997.     case 'Q':
  998.         while (len-- > 0) {
  999.         if (s + sizeof(unsigned quad) > strend)
  1000.             auquad = 0;
  1001.         else {
  1002.             bcopy(s,(char*)&auquad,sizeof(unsigned quad));
  1003.             s += sizeof(unsigned quad);
  1004.         }
  1005.         str = Str_new(43,0);
  1006.         str_numset(str,(double)auquad);
  1007.         (void)astore(stack, ++sp, str_2mortal(str));
  1008.         }
  1009.         break;
  1010. #endif
  1011.     /* float and double added gnb@melba.bby.oz.au 22/11/89 */
  1012.     case 'f':
  1013.     case 'F':
  1014.         along = (strend - s) / sizeof(float);
  1015.         if (len > along)
  1016.         len = along;
  1017.         if (checksum) {
  1018.         while (len-- > 0) {
  1019.             bcopy(s, (char *)&afloat, sizeof(float));
  1020.             s += sizeof(float);
  1021.             cdouble += afloat;
  1022.         }
  1023.         }
  1024.         else {
  1025.         while (len-- > 0) {
  1026.             bcopy(s, (char *)&afloat, sizeof(float));
  1027.             s += sizeof(float);
  1028.             str = Str_new(47, 0);
  1029.             str_numset(str, (double)afloat);
  1030.             (void)astore(stack, ++sp, str_2mortal(str));
  1031.         }
  1032.         }
  1033.         break;
  1034.     case 'd':
  1035.     case 'D':
  1036.         along = (strend - s) / sizeof(double);
  1037.         if (len > along)
  1038.         len = along;
  1039.         if (checksum) {
  1040.         while (len-- > 0) {
  1041.             bcopy(s, (char *)&adouble, sizeof(double));
  1042.             s += sizeof(double);
  1043.             cdouble += adouble;
  1044.         }
  1045.         }
  1046.         else {
  1047.         while (len-- > 0) {
  1048.             bcopy(s, (char *)&adouble, sizeof(double));
  1049.             s += sizeof(double);
  1050.             str = Str_new(48, 0);
  1051.             str_numset(str, (double)adouble);
  1052.             (void)astore(stack, ++sp, str_2mortal(str));
  1053.         }
  1054.         }
  1055.         break;
  1056.     case 'u':
  1057.         along = (strend - s) * 3 / 4;
  1058.         str = Str_new(42,along);
  1059.         while (s < strend && *s > ' ' && *s < 'a') {
  1060.         int a,b,c,d;
  1061.         char hunk[4];
  1062.  
  1063.  
  1064.         hunk[3] = '\0';
  1065.         len = (*s++ - ' ') & 077;
  1066.         while (len > 0) {
  1067.             if (s < strend && *s >= ' ')
  1068.             a = (*s++ - ' ') & 077;
  1069.             else
  1070.             a = 0;
  1071.             if (s < strend && *s >= ' ')
  1072.             b = (*s++ - ' ') & 077;
  1073.             else
  1074.             b = 0;
  1075.             if (s < strend && *s >= ' ')
  1076.             c = (*s++ - ' ') & 077;
  1077.             else
  1078.             c = 0;
  1079.             if (s < strend && *s >= ' ')
  1080.             d = (*s++ - ' ') & 077;
  1081.             else
  1082.             d = 0;
  1083.             hunk[0] = a << 2 | b >> 4;
  1084.             hunk[1] = b << 4 | c >> 2;
  1085.             hunk[2] = c << 6 | d;
  1086.             str_ncat(str,hunk, len > 3 ? 3 : len);
  1087.             len -= 3;
  1088.         }
  1089.         if (*s == '\n')
  1090.             s++;
  1091.         else if (s[1] == '\n')        /* possible checksum byte */
  1092.             s += 2;
  1093.         }
  1094.         (void)astore(stack, ++sp, str_2mortal(str));
  1095.         break;
  1096.     }
  1097.     if (checksum) {
  1098.         str = Str_new(42,0);
  1099.         if (index("fFdD", datumtype) ||
  1100.           (checksum > 32 && index("iIlLN", datumtype)) ) {
  1101.         double modf();
  1102.         double trouble;
  1103.  
  1104.  
  1105.         adouble = 1.0;
  1106.         while (checksum >= 16) {
  1107.             checksum -= 16;
  1108.             adouble *= 65536.0;
  1109.         }
  1110.         while (checksum >= 4) {
  1111.             checksum -= 4;
  1112.             adouble *= 16.0;
  1113.         }
  1114.         while (checksum--)
  1115.             adouble *= 2.0;
  1116.         along = (1 << checksum) - 1;
  1117.         while (cdouble < 0.0)
  1118.             cdouble += adouble;
  1119.         cdouble = modf(cdouble / adouble, &trouble) * adouble;
  1120.         str_numset(str,cdouble);
  1121.         }
  1122.         else {
  1123.         if (checksum < 32) {
  1124.             along = (1 << checksum) - 1;
  1125.             culong &= (unsigned long)along;
  1126.         }
  1127.         str_numset(str,(double)culong);
  1128.         }
  1129.         (void)astore(stack, ++sp, str_2mortal(str));
  1130.         checksum = 0;
  1131.     }
  1132.     }
  1133.     return sp;
  1134. }
  1135.  
  1136.  
  1137. int
  1138. do_slice(stab,str,numarray,lval,gimme,arglast)
  1139. STAB *stab;
  1140. STR *str;
  1141. int numarray;
  1142. int lval;
  1143. int gimme;
  1144. int *arglast;
  1145. {
  1146.     register STR **st = stack->ary_array;
  1147.     register int sp = arglast[1];
  1148.     register int max = arglast[2];
  1149.     register char *tmps;
  1150.     register int len;
  1151.     register int magic = 0;
  1152.     register ARRAY *ary;
  1153.     register HASH *hash;
  1154.     int oldarybase = arybase;
  1155.  
  1156.  
  1157.     if (numarray) {
  1158.     if (numarray == 2) {        /* a slice of a LIST */
  1159.         ary = stack;
  1160.         ary->ary_fill = arglast[3];
  1161.         arybase -= max + 1;
  1162.         st[sp] = str;        /* make stack size available */
  1163.         str_numset(str,(double)(sp - 1));
  1164.     }
  1165.     else
  1166.         ary = stab_array(stab);    /* a slice of an array */
  1167.     }
  1168.     else {
  1169.     if (lval) {
  1170.         if (stab == envstab)
  1171.         magic = 'E';
  1172.         else if (stab == sigstab)
  1173.         magic = 'S';
  1174. #ifdef SOME_DBM
  1175.         else if (stab_hash(stab)->tbl_dbm)
  1176.         magic = 'D';
  1177. #endif /* SOME_DBM */
  1178.     }
  1179.     hash = stab_hash(stab);        /* a slice of an associative array */
  1180.     }
  1181.  
  1182.  
  1183.     if (gimme == G_ARRAY) {
  1184.     if (numarray) {
  1185.         while (sp < max) {
  1186.         if (st[++sp]) {
  1187.             st[sp-1] = afetch(ary,
  1188.               ((int)str_gnum(st[sp])) - arybase, lval);
  1189.         }
  1190.         else
  1191.             st[sp-1] = &str_undef;
  1192.         }
  1193.     }
  1194.     else {
  1195.         while (sp < max) {
  1196.         if (st[++sp]) {
  1197.             tmps = str_get(st[sp]);
  1198.             len = st[sp]->str_cur;
  1199.             st[sp-1] = hfetch(hash,tmps,len, lval);
  1200.             if (magic)
  1201.             str_magic(st[sp-1],stab,magic,tmps,len);
  1202.         }
  1203.         else
  1204.             st[sp-1] = &str_undef;
  1205.         }
  1206.     }
  1207.     sp--;
  1208.     }
  1209.     else {
  1210.     if (numarray) {
  1211.         if (st[max])
  1212.         st[sp] = afetch(ary,
  1213.           ((int)str_gnum(st[max])) - arybase, lval);
  1214.         else
  1215.         st[sp] = &str_undef;
  1216.     }
  1217.     else {
  1218.         if (st[max]) {
  1219.         tmps = str_get(st[max]);
  1220.         len = st[max]->str_cur;
  1221.         st[sp] = hfetch(hash,tmps,len, lval);
  1222.         if (magic)
  1223.             str_magic(st[sp],stab,magic,tmps,len);
  1224.         }
  1225.         else
  1226.         st[sp] = &str_undef;
  1227.     }
  1228.     }
  1229.     arybase = oldarybase;
  1230.     return sp;
  1231. }
  1232.  
  1233.  
  1234. int
  1235. do_splice(ary,gimme,arglast)
  1236. register ARRAY *ary;
  1237. int gimme;
  1238. int *arglast;
  1239. {
  1240.     register STR **st = stack->ary_array;
  1241.     register int sp = arglast[1];
  1242.     int max = arglast[2] + 1;
  1243.     register STR **src;
  1244.     register STR **dst;
  1245.     register int i;
  1246.     register int offset;
  1247.     register int length;
  1248.     int newlen;
  1249.     int after;
  1250.     int diff;
  1251.     STR **tmparyval;
  1252.  
  1253.  
  1254.     if (++sp < max) {
  1255.     offset = ((int)str_gnum(st[sp])) - arybase;
  1256.     if (offset < 0)
  1257.         offset += ary->ary_fill + 1;
  1258.     if (++sp < max) {
  1259.         length = (int)str_gnum(st[sp++]);
  1260.         if (length < 0)
  1261.         length = 0;
  1262.     }
  1263.     else
  1264.         length = ary->ary_max + 1;        /* close enough to infinity */
  1265.     }
  1266.     else {
  1267.     offset = 0;
  1268.     length = ary->ary_max + 1;
  1269.     }
  1270.     if (offset < 0) {
  1271.     length += offset;
  1272.     offset = 0;
  1273.     if (length < 0)
  1274.         length = 0;
  1275.     }
  1276.     if (offset > ary->ary_fill + 1)
  1277.     offset = ary->ary_fill + 1;
  1278.     after = ary->ary_fill + 1 - (offset + length);
  1279.     if (after < 0) {                /* not that much array */
  1280.     length += after;            /* offset+length now in array */
  1281.     after = 0;
  1282.     if (!ary->ary_alloc) {
  1283.         afill(ary,0);
  1284.         afill(ary,-1);
  1285.     }
  1286.     }
  1287.  
  1288.  
  1289.     /* At this point, sp .. max-1 is our new LIST */
  1290.  
  1291.  
  1292.     newlen = max - sp;
  1293.     diff = newlen - length;
  1294.  
  1295.  
  1296.     if (diff < 0) {                /* shrinking the area */
  1297.     if (newlen) {
  1298.         New(451, tmparyval, newlen, STR*);    /* so remember insertion */
  1299.         Copy(st+sp, tmparyval, newlen, STR*);
  1300.     }
  1301.  
  1302.  
  1303.     sp = arglast[0] + 1;
  1304.     if (gimme == G_ARRAY) {            /* copy return vals to stack */
  1305.         if (sp + length >= stack->ary_max) {
  1306.         astore(stack,sp + length, Nullstr);
  1307.         st = stack->ary_array;
  1308.         }
  1309.         Copy(ary->ary_array+offset, st+sp, length, STR*);
  1310.         if (ary->ary_flags & ARF_REAL) {
  1311.         for (i = length, dst = st+sp; i; i--)
  1312.             str_2mortal(*dst++);    /* free them eventualy */
  1313.         }
  1314.         sp += length - 1;
  1315.     }
  1316.     else {
  1317.         st[sp] = ary->ary_array[offset+length-1];
  1318.         if (ary->ary_flags & ARF_REAL)
  1319.         str_2mortal(st[sp]);
  1320.     }
  1321.     ary->ary_fill += diff;
  1322.  
  1323.  
  1324.     /* pull up or down? */
  1325.  
  1326.  
  1327.     if (offset < after) {            /* easier to pull up */
  1328.         if (offset) {            /* esp. if nothing to pull */
  1329.         src = &ary->ary_array[offset-1];
  1330.         dst = src - diff;        /* diff is negative */
  1331.         for (i = offset; i > 0; i--)    /* can't trust Copy */
  1332.             *dst-- = *src--;
  1333.         }
  1334.         Zero(ary->ary_array, -diff, STR*);
  1335.         ary->ary_array -= diff;        /* diff is negative */
  1336.         ary->ary_max += diff;
  1337.     }
  1338.     else {
  1339.         if (after) {            /* anything to pull down? */
  1340.         src = ary->ary_array + offset + length;
  1341.         dst = src + diff;        /* diff is negative */
  1342.         Copy(src, dst, after, STR*);
  1343.         }
  1344.         Zero(&ary->ary_array[ary->ary_fill+1], -diff, STR*);
  1345.                         /* avoid later double free */
  1346.     }
  1347.     if (newlen) {
  1348.         for (src = tmparyval, dst = ary->ary_array + offset;
  1349.           newlen; newlen--) {
  1350.         *dst = Str_new(46,0);
  1351.         str_sset(*dst++,*src++);
  1352.         }
  1353.         Safefree(tmparyval);
  1354.     }
  1355.     }
  1356.     else {                    /* no, expanding (or same) */
  1357.     if (length) {
  1358.         New(452, tmparyval, length, STR*);    /* so remember deletion */
  1359.         Copy(ary->ary_array+offset, tmparyval, length, STR*);
  1360.     }
  1361.  
  1362.  
  1363.     if (diff > 0) {                /* expanding */
  1364.  
  1365.  
  1366.         /* push up or down? */
  1367.  
  1368.  
  1369.         if (offset < after && diff <= ary->ary_array - ary->ary_alloc) {
  1370.         if (offset) {
  1371.             src = ary->ary_array;
  1372.             dst = src - diff;
  1373.             Copy(src, dst, offset, STR*);
  1374.         }
  1375.         ary->ary_array -= diff;        /* diff is positive */
  1376.         ary->ary_max += diff;
  1377.         ary->ary_fill += diff;
  1378.         }
  1379.         else {
  1380.         if (ary->ary_fill + diff >= ary->ary_max)    /* oh, well */
  1381.             astore(ary, ary->ary_fill + diff, Nullstr);
  1382.         else
  1383.             ary->ary_fill += diff;
  1384.         if (after) {
  1385.             dst = ary->ary_array + ary->ary_fill;
  1386.             src = dst - diff;
  1387.             for (i = after; i; i--) {
  1388.             if (*dst)        /* str was hanging around */
  1389.                 str_free(*dst);    /*  after $#foo */
  1390.             *dst-- = *src;
  1391.             *src-- = Nullstr;
  1392.             }
  1393.         }
  1394.         }
  1395.     }
  1396.  
  1397.  
  1398.     for (src = st+sp, dst = ary->ary_array + offset; newlen; newlen--) {
  1399.         *dst = Str_new(46,0);
  1400.         str_sset(*dst++,*src++);
  1401.     }
  1402.     sp = arglast[0] + 1;
  1403.     if (gimme == G_ARRAY) {            /* copy return vals to stack */
  1404.         if (length) {
  1405.         Copy(tmparyval, st+sp, length, STR*);
  1406.         if (ary->ary_flags & ARF_REAL) {
  1407.             for (i = length, dst = st+sp; i; i--)
  1408.             str_2mortal(*dst++);    /* free them eventualy */
  1409.         }
  1410.         Safefree(tmparyval);
  1411.         }
  1412.         sp += length - 1;
  1413.     }
  1414.     else if (length) {
  1415.         st[sp] = tmparyval[length-1];
  1416.         if (ary->ary_flags & ARF_REAL)
  1417.         str_2mortal(st[sp]);
  1418.         Safefree(tmparyval);
  1419.     }
  1420.     else
  1421.         st[sp] = &str_undef;
  1422.     }
  1423.     return sp;
  1424. }
  1425.  
  1426.  
  1427. int
  1428. do_grep(arg,str,gimme,arglast)
  1429. register ARG *arg;
  1430. STR *str;
  1431. int gimme;
  1432. int *arglast;
  1433. {
  1434.     STR **st = stack->ary_array;
  1435.     register int dst = arglast[1];
  1436.     register int src = dst + 1;
  1437.     register int sp = arglast[2];
  1438.     register int i = sp - arglast[1];
  1439.     int oldsave = savestack->ary_fill;
  1440.     SPAT *oldspat = curspat;
  1441.     int oldtmps_base = tmps_base;
  1442.  
  1443.  
  1444.     savesptr(&stab_val(defstab));
  1445.     tmps_base = tmps_max;
  1446.     if ((arg[1].arg_type & A_MASK) != A_EXPR) {
  1447.     arg[1].arg_type &= A_MASK;
  1448.     dehoist(arg,1);
  1449.     arg[1].arg_type |= A_DONT;
  1450.     }
  1451.     arg = arg[1].arg_ptr.arg_arg;
  1452.     while (i-- > 0) {
  1453.     if (st[src]) {
  1454.         st[src]->str_pok &= ~SP_TEMP;
  1455.         stab_val(defstab) = st[src];
  1456.     }
  1457.     else
  1458.         stab_val(defstab) = str_mortal(&str_undef);
  1459.     (void)eval(arg,G_SCALAR,sp);
  1460.     st = stack->ary_array;
  1461.     if (str_true(st[sp+1]))
  1462.         st[dst++] = st[src];
  1463.     src++;
  1464.     curspat = oldspat;
  1465.     }
  1466.     restorelist(oldsave);
  1467.     tmps_base = oldtmps_base;
  1468.     if (gimme != G_ARRAY) {
  1469.     str_numset(str,(double)(dst - arglast[1]));
  1470.     STABSET(str);
  1471.     st[arglast[0]+1] = str;
  1472.     return arglast[0]+1;
  1473.     }
  1474.     return arglast[0] + (dst - arglast[1]);
  1475. }
  1476.  
  1477.  
  1478. int
  1479. do_reverse(arglast)
  1480. int *arglast;
  1481. {
  1482.     STR **st = stack->ary_array;
  1483.     register STR **up = &st[arglast[1]];
  1484.     register STR **down = &st[arglast[2]];
  1485.     register int i = arglast[2] - arglast[1];
  1486.  
  1487.  
  1488.     while (i-- > 0) {
  1489.     *up++ = *down;
  1490.     if (i-- > 0)
  1491.         *down-- = *up;
  1492.     }
  1493.     i = arglast[2] - arglast[1];
  1494.     Copy(down+1,up,i/2,STR*);
  1495.     return arglast[2] - 1;
  1496. }
  1497.  
  1498.  
  1499. int
  1500. do_sreverse(str,arglast)
  1501. STR *str;
  1502. int *arglast;
  1503. {
  1504.     STR **st = stack->ary_array;
  1505.     register char *up;
  1506.     register char *down;
  1507.     register int tmp;
  1508.  
  1509.  
  1510.     str_sset(str,st[arglast[2]]);
  1511.     up = str_get(str);
  1512.     if (str->str_cur > 1) {
  1513.     down = str->str_ptr + str->str_cur - 1;
  1514.     while (down > up) {
  1515.         tmp = *up;
  1516.         *up++ = *down;
  1517.         *down-- = tmp;
  1518.     }
  1519.     }
  1520.     STABSET(str);
  1521.     st[arglast[0]+1] = str;
  1522.     return arglast[0]+1;
  1523. }
  1524.  
  1525.  
  1526. static CMD *sortcmd;
  1527. static HASH *sortstash = Null(HASH*);
  1528. static STAB *firststab = Nullstab;
  1529. static STAB *secondstab = Nullstab;
  1530.  
  1531.  
  1532. int
  1533. do_sort(str,arg,gimme,arglast)
  1534. STR *str;
  1535. ARG *arg;
  1536. int gimme;
  1537. int *arglast;
  1538. {
  1539.     register STR **st = stack->ary_array;
  1540.     int sp = arglast[1];
  1541.     register STR **up;
  1542.     register int max = arglast[2] - sp;
  1543.     register int i;
  1544.     int sortcmp();
  1545.     int sortsub();
  1546.     STR *oldfirst;
  1547.     STR *oldsecond;
  1548.     ARRAY *oldstack;
  1549.     HASH *stash;
  1550.     STR *sortsubvar;
  1551.     static ARRAY *sortstack = Null(ARRAY*);
  1552.  
  1553.  
  1554.     if (gimme != G_ARRAY) {
  1555.     str_sset(str,&str_undef);
  1556.     STABSET(str);
  1557.     st[sp] = str;
  1558.     return sp;
  1559.     }
  1560.     up = &st[sp];
  1561.     sortsubvar = *up;
  1562.     st += sp;        /* temporarily make st point to args */
  1563.     for (i = 1; i <= max; i++) {
  1564.     /*SUPPRESS 560*/
  1565.     if (*up = st[i]) {
  1566.         if (!(*up)->str_pok)
  1567.         (void)str_2ptr(*up);
  1568.         else
  1569.         (*up)->str_pok &= ~SP_TEMP;
  1570.         up++;
  1571.     }
  1572.     }
  1573.     st -= sp;
  1574.     max = up - &st[sp];
  1575.     sp--;
  1576.     if (max > 1) {
  1577.     STAB *stab;
  1578.  
  1579.  
  1580.     if (arg[1].arg_type == (A_CMD|A_DONT)) {
  1581.         sortcmd = arg[1].arg_ptr.arg_cmd;
  1582.         stash = curcmd->c_stash;
  1583.     }
  1584.     else {
  1585.         if ((arg[1].arg_type & A_MASK) == A_WORD)
  1586.         stab = arg[1].arg_ptr.arg_stab;
  1587.         else
  1588.         stab = stabent(str_get(sortsubvar),TRUE);
  1589.  
  1590.  
  1591.         if (stab) {
  1592.         if (!stab_sub(stab) || !(sortcmd = stab_sub(stab)->cmd))
  1593.             fatal("Undefined subroutine \"%s\" in sort",
  1594.             stab_name(stab));
  1595.         stash = stab_stash(stab);
  1596.         }
  1597.         else
  1598.         sortcmd = Nullcmd;
  1599.     }
  1600.  
  1601.  
  1602.     if (sortcmd) {
  1603.         int oldtmps_base = tmps_base;
  1604.  
  1605.  
  1606.         if (!sortstack) {
  1607.         sortstack = anew(Nullstab);
  1608.         astore(sortstack, 0, Nullstr);
  1609.         aclear(sortstack);
  1610.         sortstack->ary_flags = 0;
  1611.         }
  1612.         oldstack = stack;
  1613.         stack = sortstack;
  1614.         tmps_base = tmps_max;
  1615.         if (sortstash != stash) {
  1616.         firststab = stabent("a",TRUE);
  1617.         secondstab = stabent("b",TRUE);
  1618.         sortstash = stash;
  1619.         }
  1620.         oldfirst = stab_val(firststab);
  1621.         oldsecond = stab_val(secondstab);
  1622. #ifndef lint
  1623.         qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
  1624. #else
  1625.         qsort(Nullch,max,sizeof(STR*),sortsub);
  1626. #endif
  1627.         stab_val(firststab) = oldfirst;
  1628.         stab_val(secondstab) = oldsecond;
  1629.         tmps_base = oldtmps_base;
  1630.         stack = oldstack;
  1631.     }
  1632. #ifndef lint
  1633.     else
  1634.         qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
  1635. #endif
  1636.     }
  1637.     return sp+max;
  1638. }
  1639.  
  1640.  
  1641. int
  1642. sortsub(str1,str2)
  1643. STR **str1;
  1644. STR **str2;
  1645. {
  1646.     stab_val(firststab) = *str1;
  1647.     stab_val(secondstab) = *str2;
  1648.     cmd_exec(sortcmd,G_SCALAR,-1);
  1649.     return (int)str_gnum(*stack->ary_array);
  1650. }
  1651.  
  1652.  
  1653. sortcmp(strp1,strp2)
  1654. STR **strp1;
  1655. STR **strp2;
  1656. {
  1657.     register STR *str1 = *strp1;
  1658.     register STR *str2 = *strp2;
  1659.     int retval;
  1660.  
  1661.  
  1662.     if (str1->str_cur < str2->str_cur) {
  1663.     /*SUPPRESS 560*/
  1664.     if (retval = memcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
  1665.         return retval;
  1666.     else
  1667.         return -1;
  1668.     }
  1669.     /*SUPPRESS 560*/
  1670.     else if (retval = memcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
  1671.     return retval;
  1672.     else if (str1->str_cur == str2->str_cur)
  1673.     return 0;
  1674.     else
  1675.     return 1;
  1676. }
  1677.  
  1678.  
  1679. int
  1680. do_range(gimme,arglast)
  1681. int gimme;
  1682. int *arglast;
  1683. {
  1684.     STR **st = stack->ary_array;
  1685.     register int sp = arglast[0];
  1686.     register int i;
  1687.     register ARRAY *ary = stack;
  1688.     register STR *str;
  1689.     int max;
  1690.  
  1691.  
  1692.     if (gimme != G_ARRAY)
  1693.     fatal("panic: do_range");
  1694.  
  1695.  
  1696.     if (st[sp+1]->str_nok || !st[sp+1]->str_pok ||
  1697.       (looks_like_number(st[sp+1]) && *st[sp+1]->str_ptr != '0') ) {
  1698.     i = (int)str_gnum(st[sp+1]);
  1699.     max = (int)str_gnum(st[sp+2]);
  1700.     if (max > i)
  1701.         (void)astore(ary, sp + max - i + 1, Nullstr);
  1702.     while (i <= max) {
  1703.         (void)astore(ary, ++sp, str = str_mortal(&str_no));
  1704.         str_numset(str,(double)i++);
  1705.     }
  1706.     }
  1707.     else {
  1708.     STR *final = str_mortal(st[sp+2]);
  1709.     char *tmps = str_get(final);
  1710.  
  1711.  
  1712.     str = str_mortal(st[sp+1]);
  1713.     while (!str->str_nok && str->str_cur <= final->str_cur &&
  1714.         strNE(str->str_ptr,tmps) ) {
  1715.         (void)astore(ary, ++sp, str);
  1716.         str = str_2mortal(str_smake(str));
  1717.         str_inc(str);
  1718.     }
  1719.     if (strEQ(str->str_ptr,tmps))
  1720.         (void)astore(ary, ++sp, str);
  1721.     }
  1722.     return sp;
  1723. }
  1724.  
  1725.  
  1726. int
  1727. do_repeatary(arglast)
  1728. int *arglast;
  1729. {
  1730.     STR **st = stack->ary_array;
  1731.     register int sp = arglast[0];
  1732.     register int items = arglast[1] - sp;
  1733.     register int count = (int) str_gnum(st[arglast[2]]);
  1734.     register int i;
  1735.     int max;
  1736.  
  1737.  
  1738.     max = items * count;
  1739.     if (max > 0 && sp + max > stack->ary_max) {
  1740.     astore(stack, sp + max, Nullstr);
  1741.     st = stack->ary_array;
  1742.     }
  1743.     if (count > 1) {
  1744.     for (i = arglast[1]; i > sp; i--)
  1745.         st[i]->str_pok &= ~SP_TEMP;
  1746.     repeatcpy((char*)&st[arglast[1]+1], (char*)&st[sp+1],
  1747.         items * sizeof(STR*), count);
  1748.     }
  1749.     sp += max;
  1750.  
  1751.  
  1752.     return sp;
  1753. }
  1754.  
  1755.  
  1756. int
  1757. do_caller(arg,maxarg,gimme,arglast)
  1758. ARG *arg;
  1759. int maxarg;
  1760. int gimme;
  1761. int *arglast;
  1762. {
  1763.     STR **st = stack->ary_array;
  1764.     register int sp = arglast[0];
  1765.     register CSV *csv = curcsv;
  1766.     STR *str;
  1767.     int count = 0;
  1768.  
  1769.  
  1770.     if (!csv)
  1771.     fatal("There is no caller");
  1772.     if (maxarg)
  1773.     count = (int) str_gnum(st[sp+1]);
  1774.     for (;;) {
  1775.     if (!csv)
  1776.         return sp;
  1777.     if (DBsub && csv->curcsv && csv->curcsv->sub == stab_sub(DBsub))
  1778.         count++;
  1779.     if (!count--)
  1780.         break;
  1781.     csv = csv->curcsv;
  1782.     }
  1783.     if (gimme != G_ARRAY) {
  1784.     STR *str = arg->arg_ptr.arg_str;
  1785.     str_set(str,csv->curcmd->c_stash->tbl_name);
  1786.     STABSET(str);
  1787.     st[++sp] = str;
  1788.     return sp;
  1789.     }
  1790.  
  1791.  
  1792. #ifndef lint
  1793.     (void)astore(stack,++sp,
  1794.       str_2mortal(str_make(csv->curcmd->c_stash->tbl_name,0)) );
  1795.     (void)astore(stack,++sp,
  1796.       str_2mortal(str_make(stab_val(csv->curcmd->c_filestab)->str_ptr,0)) );
  1797.     (void)astore(stack,++sp,
  1798.       str_2mortal(str_nmake((double)csv->curcmd->c_line)) );
  1799.     if (!maxarg)
  1800.     return sp;
  1801.     str = Str_new(49,0);
  1802.     stab_fullname(str, csv->stab);
  1803.     (void)astore(stack,++sp, str_2mortal(str));
  1804.     (void)astore(stack,++sp,
  1805.       str_2mortal(str_nmake((double)csv->hasargs)) );
  1806.     (void)astore(stack,++sp,
  1807.       str_2mortal(str_nmake((double)csv->wantarray)) );
  1808.     if (csv->hasargs) {
  1809.     ARRAY *ary = csv->argarray;
  1810.  
  1811.  
  1812.     if (!dbargs)
  1813.         dbargs = stab_xarray(aadd(stabent("DB'args", TRUE)));
  1814.     if (dbargs->ary_max < ary->ary_fill)
  1815.         astore(dbargs,ary->ary_fill,Nullstr);
  1816.     Copy(ary->ary_array, dbargs->ary_array, ary->ary_fill+1, STR*);
  1817.     dbargs->ary_fill = ary->ary_fill;
  1818.     }
  1819. #else
  1820.     (void)astore(stack,++sp,
  1821.       str_2mortal(str_make("",0)));
  1822. #endif
  1823.     return sp;
  1824. }
  1825.  
  1826.  
  1827. int
  1828. do_tms(str,gimme,arglast)
  1829. STR *str;
  1830. int gimme;
  1831. int *arglast;
  1832. {
  1833. #ifdef MSDOS
  1834.     return -1;
  1835. #else
  1836.     STR **st = stack->ary_array;
  1837.     register int sp = arglast[0];
  1838.  
  1839.  
  1840.     if (gimme != G_ARRAY) {
  1841.     str_sset(str,&str_undef);
  1842.     STABSET(str);
  1843.     st[++sp] = str;
  1844.     return sp;
  1845.     }
  1846.     (void)times(×buf);
  1847.  
  1848.  
  1849. #ifndef HZ
  1850. #define HZ 60
  1851. #endif
  1852.  
  1853.  
  1854. #ifndef lint
  1855.     (void)astore(stack,++sp,
  1856.       str_2mortal(str_nmake(((double)timesbuf.tms_utime)/HZ)));
  1857.     (void)astore(stack,++sp,
  1858.       str_2mortal(str_nmake(((double)timesbuf.tms_stime)/HZ)));
  1859.     (void)astore(stack,++sp,
  1860.       str_2mortal(str_nmake(((double)timesbuf.tms_cutime)/HZ)));
  1861.     (void)astore(stack,++sp,
  1862.       str_2mortal(str_nmake(((double)timesbuf.tms_cstime)/HZ)));
  1863. #else
  1864.     (void)astore(stack,++sp,
  1865.       str_2mortal(str_nmake(0.0)));
  1866. #endif
  1867.     return sp;
  1868. #endif
  1869. }
  1870.  
  1871.  
  1872. int
  1873. do_time(str,tmbuf,gimme,arglast)
  1874. STR *str;
  1875. struct tm *tmbuf;
  1876. int gimme;
  1877. int *arglast;
  1878. {
  1879.     register ARRAY *ary = stack;
  1880.     STR **st = ary->ary_array;
  1881.     register int sp = arglast[0];
  1882.  
  1883.  
  1884.     if (!tmbuf || gimme != G_ARRAY) {
  1885.     str_sset(str,&str_undef);
  1886.     STABSET(str);
  1887.     st[++sp] = str;
  1888.     return sp;
  1889.     }
  1890.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_sec)));
  1891.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_min)));
  1892.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_hour)));
  1893.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mday)));
  1894.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_mon)));
  1895.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_year)));
  1896.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_wday)));
  1897.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_yday)));
  1898.     (void)astore(ary,++sp,str_2mortal(str_nmake((double)tmbuf->tm_isdst)));
  1899.     return sp;
  1900. }
  1901.  
  1902.  
  1903. int
  1904. do_kv(str,hash,kv,gimme,arglast)
  1905. STR *str;
  1906. HASH *hash;
  1907. int kv;
  1908. int gimme;
  1909. int *arglast;
  1910. {
  1911.     register ARRAY *ary = stack;
  1912.     STR **st = ary->ary_array;
  1913.     register int sp = arglast[0];
  1914.     int i;
  1915.     register HENT *entry;
  1916.     char *tmps;
  1917.     STR *tmpstr;
  1918.     int dokeys = (kv == O_KEYS || kv == O_HASH);
  1919.     int dovalues = (kv == O_VALUES || kv == O_HASH);
  1920.  
  1921.  
  1922.     if (gimme != G_ARRAY) {
  1923.     str_sset(str,&str_undef);
  1924.     STABSET(str);
  1925.     st[++sp] = str;
  1926.     return sp;
  1927.     }
  1928.     (void)hiterinit(hash);
  1929.     /*SUPPRESS 560*/
  1930.     while (entry = hiternext(hash)) {
  1931.     if (dokeys) {
  1932.         tmps = hiterkey(entry,&i);
  1933.         if (!i)
  1934.         tmps = "";
  1935.         (void)astore(ary,++sp,str_2mortal(str_make(tmps,i)));
  1936.     }
  1937.     if (dovalues) {
  1938.         tmpstr = Str_new(45,0);
  1939. #ifdef DEBUGGING
  1940.         if (debug & 8192) {
  1941.         sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
  1942.             hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
  1943.         str_set(tmpstr,buf);
  1944.         }
  1945.         else
  1946. #endif
  1947.         str_sset(tmpstr,hiterval(hash,entry));
  1948.         (void)astore(ary,++sp,str_2mortal(tmpstr));
  1949.     }
  1950.     }
  1951.     return sp;
  1952. }
  1953.  
  1954.  
  1955. int
  1956. do_each(str,hash,gimme,arglast)
  1957. STR *str;
  1958. HASH *hash;
  1959. int gimme;
  1960. int *arglast;
  1961. {
  1962.     STR **st = stack->ary_array;
  1963.     register int sp = arglast[0];
  1964.     static STR *mystrk = Nullstr;
  1965.     HENT *entry = hiternext(hash);
  1966.     int i;
  1967.     char *tmps;
  1968.  
  1969.  
  1970.     if (mystrk) {
  1971.     str_free(mystrk);
  1972.     mystrk = Nullstr;
  1973.     }
  1974.  
  1975.  
  1976.     if (entry) {
  1977.     if (gimme == G_ARRAY) {
  1978.         tmps = hiterkey(entry, &i);
  1979.         if (!i)
  1980.         tmps = "";
  1981.         st[++sp] = mystrk = str_make(tmps,i);
  1982.     }
  1983.     st[++sp] = str;
  1984.     str_sset(str,hiterval(hash,entry));
  1985.     STABSET(str);
  1986.     return sp;
  1987.     }
  1988.     else
  1989.     return sp;
  1990. }
  1991.